Haskell Code (Week 4 Thursday)

-- simple programs as written in Haskell
double_hs :: Int -> Int
double_hs x = x + x

divBy5 :: Int -> Int
divBy5 x = if x < 5 then 0 else 1 + divBy5 (x - 5)

add :: Int -> Int -> Int
add x y = x + y

-- the type of abstract syntax of MinHS

data MinHS =
  Num Int
  | Lit Bool
  | If MinHS MinHS MinHS
  | Apply MinHS MinHS
  | Recfun Type Type (MinHS -> MinHS -> MinHS)
  | Plus MinHS MinHS
  | Minus MinHS MinHS
  | Eq MinHS MinHS
  | Times MinHS MinHS
  | LessThan MinHS MinHS
  | Tag String
  | TypeTag Type

-- the type of MinHS types

data Type = BoolTy | IntTy | FunTy Type Type
  deriving (Eq,Show)
  -- tells Haskell to automatically define a pretty-printer
  -- and equality comparisons for our type

-- the haskell functions above, rewritten as MinHS functions

double_minhs :: MinHS
double_minhs = Recfun IntTy IntTy (\f x -> Plus x x)

divBy5_minhs :: MinHS
divBy5_minhs = Recfun IntTy IntTy (\f x -> If (LessThan x (Num 5))
   (Num 0) (Plus (Num 1) (Apply f (Minus x (Num 5)))))

add_minhs :: MinHS
add_minhs = Recfun IntTy (FunTy IntTy IntTy) (\f x ->
    Recfun IntTy IntTy (\f y -> Plus x y))

-- to print (\f x -> Plus x x), we will invent some
-- special values "f" and "x", apply the function to those
-- special values, and print that.

printer :: MinHS -> String
printer minhs = case minhs of
  Num n -> show n
  Lit b -> show b
  Plus x y -> concat ["(", printer x, " + ", printer y, ")"]
  Minus x y -> concat ["(", printer x, " - ", printer y, ")"]
  Eq x y -> concat ["(", printer x, " == ", printer y, ")"]
  LessThan x y -> concat ["(", printer x, " < ", printer y, ")"]
  Apply x y -> concat ["(", printer x, " ", printer y, ")"]
  If c x y -> concat ["(if ", printer c, " then ", printer x,
        " else ", printer y, ")"]
  Recfun t1 t2 f ->
    let f_nm = "f" in
    let x_nm = "x" in
    concat ["(recfun ", f_nm, " :: (", show t1, " -> ", show t2,
        ") ", x_nm, " = ", printer (f (Tag f_nm) (Tag x_nm))]
  Tag nm -> nm
  TypeTag ty -> ("(TypeTag " ++ show ty ++ ")")
  _ -> error ("MinHS pretty-printer: unimplemented")

-- Skipped for now: fix the pretty-printer to not always use
-- the same names "f" and "x". It is pretty broken at the moment.

check :: MinHS -> Type -> Bool
check x ty = (if type_checker x == ty
    then True
    else error ("check: types disagree for " ++
        show (printer x, ty, type_checker x)))

type_checker :: MinHS -> Type
type_checker (Tag nm) = error ("type_checker: Tag should not appear")
type_checker (TypeTag ty) = ty
type_checker (Recfun t1 t2 f) =
    if check (f (TypeTag (FunTy t1 t2)) (TypeTag t1)) t2
    then FunTy t1 t2
    else error ("Recfun: invalid types")
type_checker (Apply f x) = case type_checker f of
    FunTy t1 t2 -> if check x t1 then t2 else (error "Apply: types")
    t -> error ("type_checker: application of " ++ show t)
type_checker (Plus x y) = if check x IntTy && check y IntTy then IntTy
    else error ("Plus: invalid types")
type_checker (Minus x y) = if check x IntTy && check y IntTy then IntTy
    else error ("Minus: invalid types")
type_checker (Eq x y) = if check x IntTy && check y IntTy then BoolTy
    else error ("Plus: invalid types")
type_checker (LessThan x y) = if check x IntTy && check y IntTy then BoolTy
    else error ("Plus: invalid types")
type_checker (If c x y) = if check c BoolTy then
        let t = type_checker x in
        if check y t then t else error ("If: invalid types")
    else error ("If: condition not a boolean")
type_checker (Num n) = IntTy
type_checker (Lit b) = BoolTy
type_checker x = error ("type_checker: unimplemented: " ++ printer x)




-- To type-check Recfun t1 t2 (\f x -> body), we will need
-- (in type-checking the body) just that x has type t2 and
-- f has type (FunTy t1 t2). So we replace f with TypeTag ...


eval :: MinHS -> MinHS
eval e = case e of
  Num _ -> e
  Lit _ -> e
  Recfun _ _ _ -> e
  Apply f x ->
    let f2 = eval f in
    let x2 = eval x in
    case f2 of
      Recfun _ _ body_fn -> eval (body_fn f2 x2)
      exp -> error ("eval: type-incorrect apply of " ++ printer exp)
  _ -> error ("eval: unimplemented: " ++ printer e)